home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / vsc92nov.zip / Code.c < prev    next >
C/C++ Source or Header  |  1992-11-02  |  33KB  |  1,285 lines
  1. /*
  2.  * Code.c -- Implementation of Scheme Bytecode
  3.  *
  4.  * (C) m.b (Matthias Blume), Apr 1992, HUB/Ger
  5.  */
  6.  
  7. # ident "@(#)Code.c    (C) M.Blume, Humboldt-Uni Berlin, 1.10"
  8.  
  9. # include <stdio.h>
  10. # include <string.h>
  11. # include <stdlib.h>
  12. # include <assert.h>
  13. # include <setjmp.h>
  14.  
  15. # include "storext.h"
  16. # include "Code.h"
  17. # include "Cont.h"
  18. # include "Symbol.h"
  19. # include "String.h"
  20. # include "Cons.h"
  21. # include "Boolean.h"
  22. # include "Procedure.h"
  23. # include "Promise.h"
  24. # include "Primitive.h"
  25. # include "Number.h"
  26. # include "identifier.h"
  27. # include "type.h"
  28. # include "except.h"
  29. # include "keyword.h"
  30. # include "speccont.h"
  31. # include "mode.h"
  32.  
  33.  
  34. /*
  35.  * This is a description of the Scheme Bytecode statements:
  36.  *
  37.  * Note: All jump instructions except JUMP_BACK jump FORWARD.
  38.  *
  39.  * The statements:
  40.  *
  41.  * 1. Access to variables:
  42.  *    GET_LOC <index>                -- local (impl. PUSH)
  43.  *    GET_ENV <frameno> <index>        -- distant (impl. PUSH)
  44.  *    GET_GLOB <symbol>            -- global (impl. PUSH)
  45.  * 2. Set variable's value:
  46.  *    PUT_LOC <index>                -- local (*NO* POP)
  47.  *    PUT_ENV <frameno> <index>        -- distant (*NO* POP)
  48.  *    PUT_GLOB <symbol>            -- global (*NO* POP)
  49.  *    PUT_LOC_POP <index>            -- local (impl. POP)
  50.  *    PUT_ENV_POP <frameno> <index>        -- distant (impl. POP)
  51.  *    PUT_GLOB_POP <symbol>            -- global (impl. POP)
  52.  * 3. extend/reset environment 
  53.  *    FRAME <size> <vector>
  54.  *    FILL_FRAME <size> <vector>
  55.  *    POP_FRAME
  56.  * 4. Constants
  57.  *    TAKE <constant>                -- (impl. PUSH)
  58.  * 5. Pop one stack element
  59.  *    POP
  60.  * 6. Combinations
  61.  *    CALL <argcnt>
  62.  *    CALL_AND_EXIT <argcnt>
  63.  *    EXIT
  64.  * 7. Conditionals (if's and "normal" cond's) and Loops
  65.  *    POP_JUMP_IF_FALSE <distance>        -- POPs always
  66.  *    POP_JUMP_IF_TRUE <distance>        -- POPs always
  67.  *    JUMP_IF_FALSE_ELSE_POP <distance>    -- POPs only, when true
  68.  *    JUMP <distance>
  69.  *    JUMP_BACK <distance>
  70.  * 8. (cond (<something>) ...)
  71.  *    JUMP_IF_TRUE_ELSE_POP <distance>    -- POPs only, when false
  72.  * 9. (cond (<something> => <func>) ...)
  73.  *    JUMP_IF_FALSE_POP <distance>        -- POPs only, when false
  74.  * 10. (lambda <formals> <body>)
  75.  *    LAMBDA <code>
  76.  * 11. (delay <expression>)
  77.  *    DELAY <code>                -- like LAMBDA
  78.  * 12. (case <item> ((...) ...) ...)
  79.  *    JUMP_IF_NOT_MEMV <distance> <list>    -- POPs only, when memv
  80.  * 13. Miscellaneous (for quasiquote):
  81.  *    CONS
  82.  *    APPEND
  83.  *            -- both statements imply two times POP and one PUSH
  84.  *    LIST_TO_VECTOR    -- one POP, one PUSH
  85.  *    VECTOR <cnt>                -- <cnt> POP's
  86.  * 14. Pushing special values
  87.  *    TAKE_TRUE
  88.  *    TAKE_FALSE
  89.  *    TAKE_NIL
  90.  */
  91.  
  92. /*
  93.  * The next section defines OP-Codes for the Scheme Bytecode Statements:
  94.  */
  95.  
  96. # define GET_LOC        0x00
  97. # define GET_ENV        0x01
  98. # define GET_GLOB        0x02
  99. # define PUT_LOC        0x03
  100. # define PUT_ENV        0x04
  101. # define PUT_GLOB        0x05
  102. # define PUT_LOC_POP        0x06
  103. # define PUT_ENV_POP        0x07
  104. # define PUT_GLOB_POP        0x08
  105. # define FRAME            0x09
  106. # define FILL_FRAME        0x0a
  107. # define POP_FRAME        0x0b
  108. # define TAKE            0x0c
  109. # define POP            0x0d
  110. # define CALL            0x0e
  111. # define CALL_AND_EXIT        0x0f
  112. # define EXIT            0x10
  113. # define JUMP            0x11
  114. # define JUMP_BACK        0x12
  115. # define POP_JUMP_IF_FALSE    0x13
  116. # define POP_JUMP_IF_TRUE    0x14
  117. # define JUMP_IF_FALSE_ELSE_POP    0x15
  118. # define JUMP_IF_TRUE_ELSE_POP    0x16
  119. # define JUMP_IF_FALSE_POP    0x17
  120. # define JUMP_IF_TRUE_POP    0x18
  121. # define LAMBDA            0x19
  122. # define DELAY            0x1a
  123. # define JUMP_IF_NOT_MEMV    0x1b
  124. # define CONS            0x1c
  125. # define APPEND            0x1d
  126. # define LIST_TO_VECTOR        0x1e
  127. # define VECTOR            0x1f
  128. # define TAKE_TRUE        0x20
  129. # define TAKE_FALSE        0x21
  130. # define TAKE_NIL        0x22
  131.  
  132. # define GET_LOC_len            (1 + 1)
  133. # define GET_ENV_len            (1 + 2 * 1)
  134. # define GET_GLOB_len            (1 + 1)
  135. # define PUT_LOC_len            (1 + 1)
  136. # define PUT_ENV_len            (1 + 2 * 1)
  137. # define PUT_GLOB_len            (1 + 1)
  138. # define PUT_LOC_POP_len        (1 + 1)
  139. # define PUT_ENV_POP_len        (1 + 2 * 1)
  140. # define PUT_GLOB_POP_len        (1 + 1)
  141. # define FRAME_len            (1 + 2 * 1)
  142. # define FILL_FRAME_len            (1 + 2 * 1)
  143. # define POP_FRAME_len            (1)
  144. # define TAKE_len            (1 + 1)
  145. # define POP_len            (1)
  146. # define CALL_len            (1 + 1)
  147. # define CALL_AND_EXIT_len        (1 + 1)
  148. # define EXIT_len            (1)
  149. # define JUMP_len            (1 + 1)
  150. # define JUMP_BACK_len            (1 + 1)
  151. # define POP_JUMP_IF_FALSE_len        (1 + 1)
  152. # define POP_JUMP_IF_TRUE_len        (1 + 1)
  153. # define JUMP_IF_FALSE_ELSE_POP_len    (1 + 1)
  154. # define JUMP_IF_TRUE_ELSE_POP_len    (1 + 1)
  155. # define JUMP_IF_FALSE_POP_len        (1 + 1)
  156. # define JUMP_IF_TRUE_POP_len        (1 + 1)
  157. # define LAMBDA_len            (1 + 1)
  158. # define DELAY_len            (1 + 1)
  159. # define JUMP_IF_NOT_MEMV_len        (1 + 2 * 1)
  160. # define CONS_len            (1)
  161. # define APPEND_len            (1)
  162. # define LIST_TO_VECTOR_len        (1)
  163. # define VECTOR_len            (1 + 1)
  164. # define TAKE_TRUE_len            (1)
  165. # define TAKE_FALSE_len            (1)
  166. # define TAKE_NIL_len            (1)
  167.  
  168. static
  169. struct stat_desc {
  170.   unsigned short opcode;
  171.   int length;
  172.   const char *name;
  173. } stat_desc [0x23] = {
  174.  
  175.   /* alphabetically ordered.... */
  176.  
  177.   { APPEND, APPEND_len, "append" },
  178.   { CALL, CALL_len, "call" },
  179.   { CALL_AND_EXIT, CALL_AND_EXIT_len, "call-and-exit" },
  180.   { CONS, CONS_len, "cons" },
  181.   { DELAY, DELAY_len, "delay" },
  182.   { EXIT, EXIT_len, "exit" },
  183.   { FILL_FRAME, FILL_FRAME_len, "fill-frame" },
  184.   { FRAME, FRAME_len, "frame" },
  185.   { GET_ENV, GET_ENV_len, "get-env" },
  186.   { GET_GLOB, GET_GLOB_len, "get-glob" },
  187.   { GET_LOC, GET_LOC_len, "get-loc" },
  188.   { JUMP, JUMP_len, "jump" },
  189.   { JUMP_BACK, JUMP_BACK_len, "jump-back" },
  190.   { JUMP_IF_FALSE_ELSE_POP, JUMP_IF_FALSE_ELSE_POP_len,
  191.                         "jump-if-false-else-pop" },
  192.   { JUMP_IF_FALSE_POP, JUMP_IF_FALSE_POP_len, "jump-if-false-pop" },
  193.   { JUMP_IF_NOT_MEMV, JUMP_IF_NOT_MEMV_len, "jump-if-not-memv" },
  194.   { JUMP_IF_TRUE_ELSE_POP, JUMP_IF_TRUE_ELSE_POP_len, "jump-if-true-else-pop" },
  195.   { JUMP_IF_TRUE_POP, JUMP_IF_TRUE_POP_len, "jump-if-true-pop" },
  196.   { LAMBDA, LAMBDA_len, "lambda" },
  197.   { LIST_TO_VECTOR, LIST_TO_VECTOR_len, "list->vector" },
  198.   { POP, POP_len, "pop" },
  199.   { POP_FRAME, POP_FRAME_len, "pop-frame" },
  200.   { POP_JUMP_IF_FALSE, POP_JUMP_IF_FALSE_len, "pop-jump-if-false" },
  201.   { POP_JUMP_IF_TRUE, POP_JUMP_IF_TRUE_len, "pop-jump-if-true" },
  202.   { PUT_ENV, PUT_ENV_len, "put-env" },
  203.   { PUT_ENV_POP, PUT_ENV_POP_len, "put-env-pop" },
  204.   { PUT_GLOB, PUT_GLOB_len, "put-glob" },
  205.   { PUT_GLOB_POP, PUT_GLOB_POP_len, "put-glob-pop" },
  206.   { PUT_LOC, PUT_LOC_len, "put-loc" },
  207.   { PUT_LOC_POP, PUT_LOC_POP_len, "put-loc-pop" },
  208.   { TAKE, TAKE_len, "take" },
  209.   { TAKE_FALSE, TAKE_FALSE_len, "take-false" },
  210.   { TAKE_NIL, TAKE_NIL_len, "take-nil" },
  211.   { TAKE_TRUE, TAKE_TRUE_len, "take-true" },
  212.   { VECTOR, VECTOR_len, "vector" },
  213. };
  214.  
  215. # ifdef VM_INSTRUCTION_COUNTING
  216. static unsigned long vm_counts [0x23];
  217. # define COUNT(x) (vm_counts [x]++)
  218. static void vm_statistics (void)
  219. {
  220.   int i;
  221.  
  222.   for (i = 0; i < (sizeof stat_desc / sizeof stat_desc[0]); i++)
  223.     fprintf (stderr, "\t*\t%10lu\t%s\n",
  224.          vm_counts [stat_desc [i].opcode],
  225.          stat_desc [i].name);
  226. }
  227. # else
  228. # define COUNT(x) ((void)0)
  229. # endif
  230.  
  231. static
  232. struct stat_desc *find_stat (const char *name, unsigned short len)
  233. {
  234.   int start = 0;
  235.   int stop  = sizeof stat_desc / sizeof (struct stat_desc) - 1;
  236.   int m, cmp, llen;
  237.  
  238.   while (start <= stop) {
  239.     m = (start + stop) / 2;
  240.     cmp = strncmp (name, stat_desc [m].name, len);
  241.     if (cmp == 0) {
  242.       llen = strlen (stat_desc [m].name);
  243.       if (llen == len)
  244.     return stat_desc + m;
  245.       else
  246.     cmp = -1;
  247.     }
  248.     if (cmp < 0)
  249.       stop = m - 1;
  250.     else
  251.       start = m + 1;
  252.   }
  253.   error ("vscm-asm: bad operation code");
  254.   /*NOTREACHED*/
  255. }
  256.  
  257. /*
  258.  * And now the normal stuff needed by type management:
  259.  */
  260.  
  261. static
  262. size_t size_hook (void *vcode)
  263. {
  264.   return (sizeof (ScmCode) +
  265.         (((ScmCode *)vcode)->length - 1) * sizeof (unsigned short));
  266. }
  267.  
  268. static
  269. void apply_to_subs (void *vcode, applied_proc proc, void *cd)
  270. {
  271.   ScmCode *code = vcode;
  272.  
  273.   (* proc) ((void *)&code->argument_names, cd);
  274.   (* proc) ((void *)&code->constants, cd);
  275.   (* proc) ((void *)&code->proc_name, cd);
  276. }
  277.  
  278. static
  279. void dump (void *vcode, FILE *file)
  280. {
  281.   ScmCode *code = (ScmCode *) vcode;
  282.   unsigned i;
  283.  
  284.   fprintf (file, "%uX%c",
  285.         (unsigned int) (code->arg_cnt),
  286.         code->take_rest ? 'y' : 'n');
  287.   dump_ul (code->stack_requirement, file);
  288.   dump_ul (code->length, file);
  289.   i = 0;
  290.   while(i < code->length) {
  291.     dump_ul (code->array [i], file);
  292.     i++;
  293.   }
  294. }
  295.  
  296. static
  297. void *restore_init (FILE *file)
  298. {
  299.   ScmCode *code;
  300.   unsigned i;
  301.   unsigned short length, arg_cnt, stack_requirement;
  302.   unsigned char c;
  303.  
  304.   if (fscanf (file, "%huX%c",
  305.             &arg_cnt, &c) < 2)
  306.     fatal ("bad dump file format (Code)");
  307.   stack_requirement = restore_ul (file);
  308.   length = restore_ul (file);
  309.   code = getmem (ScmType (Code),
  310.           sizeof (ScmCode) + (length - 1) * sizeof (unsigned short));
  311.   code->arg_cnt = arg_cnt;
  312.   code->stack_requirement = stack_requirement;
  313.   code->length = length;
  314.   code->take_rest = (c == 'y');
  315.   i = 0;
  316.   while(i < length) {
  317.     code->array [i] = restore_ul (file);
  318.     i++;
  319.   }
  320.   return code;
  321. }
  322.  
  323. static
  324. void display (void *vcode, putc_proc pp, void *cd)
  325. {
  326.   char buf [32];
  327.   ScmCode *code = vcode;
  328.  
  329.   sprintf (buf, "#<Code %p ", vcode);
  330.   putc_string (buf, pp, cd);
  331.   display_object (code->proc_name, pp, cd);
  332.   sprintf (buf, " %u%s>", (unsigned) code->arg_cnt,
  333.         code->take_rest ? "+" : "");
  334.   putc_string (buf, pp, cd);
  335. }
  336.  
  337. static void *reverse_old = NULL;
  338. static void *reverse_new = NULL;
  339. static void *append_save = NULL;
  340. static void *constants_save = NULL;
  341. static ScmProcedure *proc_save = NULL;
  342.  
  343. # define MAX_INTERRUPTS 16        /* this should be enough */
  344. static unsigned pending_interrupts = 0;
  345. static struct {
  346.   void *vect;
  347.   unsigned short cont;
  348. } int_table [MAX_INTERRUPTS];
  349.  
  350. static void appl_int_table (void *tab, applied_proc proc, void *cd)
  351. {
  352.   int i;
  353.  
  354.   for (i = 0; i < MAX_INTERRUPTS; i++)
  355.     (* proc) ((void *)&int_table[i].vect, cd);
  356. }
  357.  
  358. static
  359. void module_init (void)
  360. {
  361.   register_global_variable (reverse_old);
  362.   register_global_variable (reverse_new);
  363.   register_global_variable (append_save);
  364.   register_global_variable (constants_save);
  365.   register_global_variable (proc_save);
  366.   register_global_object (int_table, appl_int_table);
  367. }
  368.  
  369. static
  370. struct scheme_od_extension ext = {
  371.   display, display,
  372.   NULL,    NULL,    /* Note: bytecode should never be compared to anything*/
  373. };
  374.  
  375. OD_VECTOR (ScmCode_od_vector,
  376.   0,
  377.   size_hook,
  378.   apply_to_subs,
  379.   CODE_IDENTIFIER,
  380.   dump, restore_init, NULL,
  381.   module_init,
  382.   NULL, NULL,
  383.   &ext
  384. );
  385.  
  386. /*
  387.  * The interpreter (code emulator)
  388.  */
  389.  
  390. static void *ScmMemv (void *item, void *list)
  391. {
  392.   while (ScmTypeOf (list) == ScmType (Cons))
  393.     if (eqv_object (((ScmCons *) list)->car, item))
  394.       return list;
  395.     else
  396.       list = ((ScmCons *) list)->cdr;
  397.   return &ScmFalse;
  398. }
  399.  
  400. unsigned long ScmListLength (void *l)
  401. {
  402.   unsigned long i;
  403.  
  404.   i = 0;
  405.   while (ScmTypeOf (l) == ScmType (Cons))
  406.     l = ((ScmCons *) l)->cdr,
  407.     i++;
  408.   return i;
  409. }
  410.  
  411. void *ScmReverseList (void *l)
  412. {
  413.   ScmCons *cons;
  414.   void *r;
  415.   unsigned long len, i;
  416.  
  417.   len = ScmListLength (l);
  418.   if (len == 0)
  419.     return &ScmNil;
  420.   reverse_old = l;
  421.   cons = getmem (NULL, len * sizeof (ScmCons));
  422.   r = reverse_old;
  423.   reverse_old = NULL;
  424.   for (i = len; i-- > 0; ) {
  425.     cons [i]._ = ScmType (Cons);
  426.     cons [i].car = ((ScmCons *) r)->car;
  427.     r = ((ScmCons *) r)->cdr;
  428.     cons [i].cdr = cons + i + 1;
  429.   }
  430.   cons [len - 1].cdr = &ScmNil;
  431.   return cons;
  432. }
  433.  
  434. void *ScmReverseIP2 (void *l, void *r)
  435. {
  436.   ScmCons *tmp;
  437.  
  438.   while (ScmTypeOf (l) == ScmType (Cons)) {
  439.     tmp = l;
  440.     l = tmp->cdr;
  441.     tmp->cdr = r;
  442.     r = tmp;
  443.   }
  444.   return r;
  445. }
  446.  
  447. void *ScmAppendTwoLists (void *l1, void *l2)
  448. {
  449.   ScmCons *cons;
  450.   unsigned long len, i;
  451.   void *r;
  452.  
  453.   len = ScmListLength (l1);
  454.   if (len == 0)
  455.     return l2;
  456.   reverse_old = l1;
  457.   append_save = l2;
  458.   cons = getmem (NULL, len * sizeof (ScmCons));
  459.   l2 = append_save;
  460.   r = reverse_old;
  461.   append_save = reverse_old = NULL;
  462.   for (i = 0; i < len; i++) {
  463.     cons [i]._ = ScmType (Cons);
  464.     cons [i].car = ((ScmCons *) r)->car;
  465.     r = ((ScmCons *) r)->cdr;
  466.     cons [i].cdr = cons + i + 1;
  467.   }
  468.   cons [len - 1].cdr = l2;
  469.   return cons;
  470. }
  471.  
  472. void ScmListToVector (void)
  473. {
  474.   ScmCons *l;
  475.   unsigned long len, i;
  476.   ScmVector *vect;
  477.  
  478.   vect = NewScmVector (len = ScmListLength (ScmPeek ()));
  479.   l = ScmPeek ();
  480.   for (i = 0; i < len; i++) {
  481.     vect->array [i] = l->car;
  482.     l = l->cdr;
  483.   }
  484.   ScmSetTop (vect);
  485. }
  486.  
  487. void ScmPrepareProcedureCall (void  *vproc, unsigned short argcnt)
  488. {
  489.   ScmVector *vect;
  490.   unsigned i, j, siz;
  491.   ScmCons *cons;
  492.  
  493.   proc_save = vproc;
  494.   ScmPushContinuation (((ScmCode *) proc_save->code)->stack_requirement);
  495.   ScmCC.code = proc_save->code;
  496.   ScmCC.constants = ScmCC.code->constants;
  497.  
  498.   siz = ScmCC.code->arg_cnt + (ScmCC.code->take_rest ? 1 : 0);
  499.   if (siz > 0) {
  500.     vect = NewScmVector (siz + 2);
  501.     ScmCC.environ = vect;
  502.     vect->array [0] = proc_save->env;
  503.     vect->array [1] = ScmCC.code->argument_names;
  504.     siz = ScmCC.code->arg_cnt;
  505.     if (siz > argcnt)
  506.       error ("too few arguments to procedure %w", proc_save);
  507.     for (i = 0; i < siz; i++)
  508.       vect->array [i + 2] = ScmCPop (ScmCC.father);
  509.     if (ScmCC.code->take_rest) {
  510.       if (i >= argcnt)
  511.     vect->array [i + 2] = &ScmNil;
  512.       else {
  513.     cons = getmem (NULL, (argcnt - i) * sizeof (ScmCons));
  514.     for (j = i; j < argcnt; j++) {
  515.       cons [j - i]._ = ScmType (Cons);
  516.       cons [j - i].car = ScmCPop (ScmCC.father);
  517.       cons [j - i].cdr = cons + j - i + 1;
  518.     }
  519.     cons [argcnt - i - 1].cdr = &ScmNil;
  520.     vect = ScmCC.environ;
  521.     vect->array [i + 2] = cons;
  522.       }
  523.     } else
  524.       if (i < argcnt)
  525.     error ("too many arguments to procedure %w", proc_save);
  526.   } else {
  527.     ScmCC.environ = proc_save->env;
  528.     if (argcnt != 0)
  529.       error ("too many arguments to procedure %w", proc_save);
  530.   }
  531.   proc_save = NULL;
  532. }
  533.  
  534. static unsigned short active_primitive = SCM_VM_TRAP_CONT;
  535.  
  536. static some_interrupt_pending = 0;
  537.  
  538. void ScmRegisterInterrupt (unsigned short cont, void *vvect)
  539. {
  540.   some_interrupt_pending = 1;
  541.   if (pending_interrupts >= MAX_INTERRUPTS)
  542.     reset ("too many pending interrupts");
  543.   int_table [pending_interrupts].vect = vvect;
  544.   int_table [pending_interrupts].cont = cont;
  545.   pending_interrupts++;
  546. }
  547.  
  548. static void handle_interrupts (void)
  549. {
  550.   ScmVector *vect;
  551.   void *tmp;
  552.   unsigned i, j;
  553.  
  554.   for (i = 0; i < pending_interrupts; i++) {
  555.     active_primitive = int_table [i].cont;
  556.     vect = int_table [i].vect;
  557.     ScmPushPrimitiveContinuation (vect, vect->length - 1);
  558.     active_primitive = SCM_VM_TRAP_CONT;
  559.     vect = ScmCC.environ;
  560.     for (j = vect->length - 1; j > 0; j--) {
  561.       tmp = vect->array [j];
  562.       ScmPush (tmp);
  563.       vect = ScmCC.environ;
  564.     }
  565.     int_table [i].vect = NULL;
  566.     ScmPrepareProcedureCall (vect->array [0], vect->length - 1);
  567.   }
  568.   pending_interrupts = 0;
  569. }
  570.  
  571. static int asyn_interrupt = 0;
  572. static int instant_interrupt_handling = 0;
  573. static int memorized_instant_interrupt_handling;
  574. static jmp_buf reactivation_point;
  575.  
  576. void ScmInstantInterruptHandling (int state)
  577. {
  578.   instant_interrupt_handling = state;
  579. }
  580.  
  581. void announce_gc_start (void)
  582. {
  583.   memorized_instant_interrupt_handling = instant_interrupt_handling;
  584.   instant_interrupt_handling = 0;
  585. }
  586.  
  587. void announce_gc_end (void)
  588. {
  589.   instant_interrupt_handling = memorized_instant_interrupt_handling;
  590. }
  591.  
  592. void ScmRegisterAsynInterrupt (void)
  593. {
  594.   some_interrupt_pending = 1;
  595.   asyn_interrupt = 1;
  596.   if (instant_interrupt_handling) {
  597.     instant_interrupt_handling = 0;
  598.     ScmPush (&ScmEof);
  599.     longjmp (reactivation_point, 1);
  600.   }
  601. }
  602.  
  603. static void handle_asyn_interrupt (void)
  604. {
  605.   void *intmode = ScmMode (SCM_INTERRUPT_MODE);
  606.  
  607.   asyn_interrupt = 0;
  608.   if (intmode == NULL)
  609.     reset ("Interrupt");
  610.   else {
  611.     active_primitive = SCM_VM_INTERRUPT_CONT;
  612.     ScmPushPrimitiveContinuation (intmode, 0);
  613.     active_primitive = SCM_VM_TRAP_CONT;
  614.     ScmPrepareProcedureCall (ScmCC.environ, 0);
  615.   }
  616. }
  617.  
  618. /*
  619.  * Note: environment frames are implemented as plain ScmVectors using the
  620.  * the following convention:
  621.  *  - env->array [0] always points back to the father frame
  622.  *  - env->array [1] points to the environment description
  623.  *  - env->array [2-] is the actual frame
  624.  */
  625.  
  626. volatile void ScmVM (void)
  627. {
  628.   unsigned const short *cp;
  629.   unsigned short index, frameno, con, siz, dist;
  630.   ScmVector *env_frame, *vect;
  631.   ScmPromise *prom;
  632.   ScmProcedure *proc;
  633.   ScmCons *cons;
  634.   void *tmp;
  635.   unsigned short argcnt;
  636.  
  637. # ifdef VM_INSTRUCTION_COUNTING
  638.   atexit (vm_statistics);
  639. # endif
  640.  
  641.   setjmp (reactivation_point);
  642.   /* loop forever */
  643.   for (;;) {
  644.     if (some_interrupt_pending) {
  645.       some_interrupt_pending = 0;
  646.       if (asyn_interrupt)
  647.     handle_asyn_interrupt ();
  648.       if (pending_interrupts > 0)
  649.     handle_interrupts ();
  650.     }
  651.     cp = ScmCC.code->array + ScmCC.nxt_stat;
  652.     COUNT(cp[0]);
  653.     switch (cp [0]) {
  654.     case GET_LOC:
  655.       index = cp [1];
  656.       ScmPush (((ScmVector *) (ScmCC.environ))->array [index + 2]);
  657.       ScmCC.nxt_stat += GET_LOC_len;
  658.       break;
  659.     case GET_ENV:
  660.       frameno = cp [1];
  661.       index = cp [2];
  662.       for (env_frame = ScmCC.environ;
  663.         frameno-- > 0;
  664.         env_frame = env_frame->array [0]);
  665.       ScmPush (env_frame->array [index + 2]);
  666.       ScmCC.nxt_stat += GET_ENV_len;
  667.       break;
  668.     case GET_GLOB:
  669.       con = cp [1];
  670.       tmp = ((ScmSymbol *) (ScmCC.constants->array [con]))->value;
  671.       if (tmp == NULL)
  672.     error ("Unbound variable: %w", ScmCC.constants->array [con]);
  673.       ScmPush (tmp);
  674.       ScmCC.nxt_stat += GET_GLOB_len;
  675.       break;
  676.     case PUT_LOC:
  677.       index = cp [1];
  678.       ((ScmVector *) (ScmCC.environ))->array [index + 2] = ScmPeek ();
  679.       ScmCC.nxt_stat += PUT_LOC_len;
  680.       break;
  681.     case PUT_ENV:
  682.       frameno = cp [1];
  683.       index = cp [2];
  684.       for (env_frame = ScmCC.environ;
  685.         frameno-- > 0;
  686.         env_frame = env_frame->array [0]);
  687.       env_frame->array [index + 2] = ScmPeek ();
  688.       ScmCC.nxt_stat += PUT_ENV_len;
  689.       break;
  690.     case PUT_GLOB:
  691.       con = cp [1];
  692.       ((ScmSymbol *) (ScmCC.constants->array [con]))->value = ScmPeek ();
  693.       ScmCC.nxt_stat += PUT_GLOB_len;
  694.       break;
  695.     case PUT_LOC_POP:
  696.       index = cp [1];
  697.       ((ScmVector *) (ScmCC.environ))->array [index + 2] = ScmPop ();
  698.       ScmCC.nxt_stat += PUT_LOC_POP_len;
  699.       break;
  700.     case PUT_ENV_POP:
  701.       frameno = cp [1];
  702.       index = cp [2];
  703.       for (env_frame = ScmCC.environ;
  704.         frameno-- > 0;
  705.         env_frame = env_frame->array [0]);
  706.       env_frame->array [index + 2] = ScmPop ();
  707.       ScmCC.nxt_stat += PUT_ENV_POP_len;
  708.       break;
  709.     case PUT_GLOB_POP:
  710.       con = cp [1];
  711.       ((ScmSymbol *) (ScmCC.constants->array [con]))->value
  712.     = ScmPop ();
  713.       ScmCC.nxt_stat += PUT_GLOB_POP_len;
  714.       break;
  715.     case FRAME:
  716.       siz = cp [1];
  717.       con = cp [2];
  718.       env_frame = NewScmVector (siz + 2);
  719.       env_frame->array [0] = ScmCC.environ;
  720.       env_frame->array [1] = ScmCC.constants->array [con];
  721.       ScmCC.environ = env_frame;
  722.       ScmCC.nxt_stat += FRAME_len;
  723.       break;
  724.     case FILL_FRAME:
  725.       siz = cp [1];
  726.       con = cp [2];
  727.       env_frame = NewScmVector (siz + 2);
  728.       env_frame->array [0] = ScmCC.environ;
  729.       env_frame->array [1] = ScmCC.constants->array [con];
  730.       ScmCC.environ = env_frame;
  731.       while (siz-- > 0)
  732.         env_frame->array [siz + 2] = ScmPop ();
  733.       ScmCC.nxt_stat += FILL_FRAME_len;
  734.       break;
  735.     case POP_FRAME:
  736.       ScmCC.environ = ((ScmVector *) (ScmCC.environ))->array [0];
  737.       ScmCC.nxt_stat += POP_FRAME_len;
  738.       break;
  739.     case TAKE:
  740.       con = cp [1];
  741.       ScmPush (ScmCC.constants->array [con]);
  742.       ScmCC.nxt_stat += TAKE_len;
  743.       break;
  744.     case POP:
  745.       (void) ScmPop ();
  746.       ScmCC.nxt_stat += POP_len;
  747.       break;
  748.     case CALL:
  749.       argcnt = cp [1];
  750.       ScmCC.nxt_stat += CALL_len;
  751. # ifdef DEBUG
  752.       {
  753.     int i;
  754.     warning ("DEBUG: Calling :");
  755.     for (i = 0; i <= argcnt; i++)
  756.       warning("       %w", ScmCC.stack->array[ScmCC.stack_top - 1 - i]);
  757.       }
  758. # endif
  759. call_entry_point:
  760.       tmp = ScmPop ();
  761.       if (ScmTypeOf (tmp) == ScmType (Procedure)) {
  762.     ScmPrepareProcedureCall (tmp, argcnt);
  763.       } else if (ScmTypeOf (tmp) == ScmType (Primitive)) {
  764.     ScmPrimitive *prim = tmp;
  765.     if (prim->expected_argcnt >= 0 && prim->expected_argcnt != argcnt)
  766.       error ("wrong argcnt to primitive procedure %w", prim);
  767.     active_primitive = prim->seq_num;
  768.     (* prim->code) (argcnt);
  769.     active_primitive = SCM_VM_TRAP_CONT;
  770.     if (ScmCC.call_again > 0) {
  771.       argcnt = ScmCC.call_again - 1;
  772.       ScmCC.call_again = 0;
  773.       /* is there any chance to conveniently express this without goto ? */
  774.       goto call_entry_point;
  775. # ifdef DEBUG
  776.       {
  777.         int i;
  778.         warning ("DEBUG: Switching to :");
  779.         for (i = 0; i <= argcnt; i++)
  780.           warning("       %w", ScmCC.stack->array[ScmCC.stack_top - 1 - i]);
  781.       }
  782.     } else {
  783.       warning ("DEBUG: Returning :");
  784.       warning("       %w", ScmPeek());
  785. # endif
  786.     }
  787.     goto c_cont_loop;
  788.       } else if (ScmTypeOf (tmp) == ScmType (Continuation)) {
  789.     if (argcnt != 1)
  790.       error ("VM: call to escape procedure with argcnt = %u",
  791.             (unsigned) argcnt);
  792. # ifdef DEBUG
  793.     warning ("DEBUG: Escaping...");
  794. # endif
  795.     reverse_new = ScmPop ();
  796.     ScmSetContinuation (tmp);
  797.     ScmPush (reverse_new);
  798.     reverse_new = NULL;
  799.     goto c_cont_loop;
  800.       } else
  801.         error ("VM: call of non-procedure: %w", tmp);
  802.       break;
  803.     case CALL_AND_EXIT:
  804.       argcnt = cp [1];
  805.       /* incrementing nxt_stat is not necessary */
  806. # ifdef DEBUG
  807.       {
  808.     int i;
  809.     warning ("DEBUG: Switching to :");
  810.     for (i = 0; i <= argcnt; i++)
  811.       warning("       %w", ScmCC.stack->array[ScmCC.stack_top - 1 - i]);
  812.       }
  813. # endif
  814.       ScmRevertToFatherContinuation (argcnt + 1);
  815.       goto call_entry_point;
  816.       break;
  817.     case EXIT:
  818.       /* don't need to increment nxt_stat */
  819. # ifdef DEBUG
  820.       warning ("DEBUG: Returning :");
  821.       warning("       %w", ScmPeek());
  822. # endif
  823.       ScmRevertToFatherContinuation (1);
  824. c_cont_loop:
  825.       while (ScmCC.code == NULL) {
  826.     ScmPrimitive *prim;
  827.     active_primitive = ScmCC.nxt_stat;
  828.     prim = GetScmPrimitive (active_primitive);
  829.     (* prim->cont) ();
  830.     active_primitive = SCM_VM_TRAP_CONT;
  831.     if (ScmCC.call_again > 0) {
  832.       argcnt = ScmCC.call_again - 1;
  833.       ScmCC.call_again = 0;
  834.       goto call_entry_point;
  835.     }
  836.       }
  837.       break;
  838.     case JUMP:
  839.       dist = cp [1];
  840.       ScmCC.nxt_stat += JUMP_len + dist;
  841.       break;
  842.     case JUMP_BACK:
  843.       dist = cp [1];
  844.       ScmCC.nxt_stat += JUMP_BACK_len;
  845.       ScmCC.nxt_stat -= dist;
  846.       break;
  847.     case POP_JUMP_IF_FALSE:
  848.       dist = cp [1];
  849.       if (ScmPop () == &ScmFalse)
  850.     ScmCC.nxt_stat += POP_JUMP_IF_FALSE_len + dist;
  851.       else
  852.     ScmCC.nxt_stat += POP_JUMP_IF_FALSE_len;
  853.       break;
  854.     case POP_JUMP_IF_TRUE:
  855.       dist = cp [1];
  856.       if (ScmPop () != &ScmFalse)
  857.     ScmCC.nxt_stat += POP_JUMP_IF_TRUE_len + dist;
  858.       else
  859.     ScmCC.nxt_stat += POP_JUMP_IF_TRUE_len;
  860.       break;
  861.     case JUMP_IF_FALSE_ELSE_POP:
  862.       dist = cp [1];
  863.       if (ScmPeek () == &ScmFalse)
  864.     ScmCC.nxt_stat += JUMP_IF_FALSE_ELSE_POP_len + dist;
  865.       else {
  866.     (void) ScmPop ();
  867.     ScmCC.nxt_stat += JUMP_IF_FALSE_ELSE_POP_len;
  868.       }
  869.       break;
  870.     case JUMP_IF_TRUE_ELSE_POP:
  871.       dist = cp [1];
  872.       if (ScmPeek () != &ScmFalse)
  873.     ScmCC.nxt_stat += JUMP_IF_TRUE_ELSE_POP_len + dist;
  874.       else {
  875.     (void) ScmPop ();
  876.     ScmCC.nxt_stat += JUMP_IF_TRUE_ELSE_POP_len;
  877.       }
  878.       break;
  879.     case JUMP_IF_FALSE_POP:
  880.       dist = cp [1];
  881.       if (ScmPeek () == &ScmFalse) {
  882.     (void) ScmPop ();
  883.     ScmCC.nxt_stat += JUMP_IF_FALSE_POP_len + dist;
  884.       } else
  885.     ScmCC.nxt_stat += JUMP_IF_FALSE_POP_len;
  886.       break;
  887.     case JUMP_IF_TRUE_POP:
  888.       dist = cp [1];
  889.       if (ScmPeek () != &ScmFalse) {
  890.     (void) ScmPop ();
  891.     ScmCC.nxt_stat += JUMP_IF_TRUE_POP_len + dist;
  892.       } else
  893.     ScmCC.nxt_stat += JUMP_IF_TRUE_POP_len;
  894.       break;
  895.     case LAMBDA:
  896.       con = cp [1];
  897.       proc = new (ScmType (Procedure));
  898.       proc->env = ScmCC.environ;
  899.       proc->code = ScmCC.constants->array [con];
  900.       ScmPush (proc);
  901.       ScmCC.nxt_stat += LAMBDA_len;
  902.       break;
  903.     case DELAY:
  904.       con = cp [1];
  905.       prom = new (ScmType (Promise));
  906.       prom->env = ScmCC.environ;
  907.       prom->code_or_value = ScmCC.constants->array [con];
  908.       ScmPush (prom);
  909.       ScmCC.nxt_stat += DELAY_len;
  910.       break;
  911.     case JUMP_IF_NOT_MEMV:
  912.       dist = cp [1];
  913.       con = cp [2];
  914.       if (ScmMemv (ScmPeek (), ScmCC.constants->array [con])
  915.         == &ScmFalse) {
  916.     ScmCC.nxt_stat += JUMP_IF_NOT_MEMV_len + dist;
  917.       } else {
  918.     (void) ScmPop ();
  919.     ScmCC.nxt_stat += JUMP_IF_NOT_MEMV_len;
  920.       }
  921.       break;
  922.     case CONS:
  923.       cons = new (ScmType (Cons));
  924.       cons->car = ScmPop ();
  925.       cons->cdr = ScmPeek ();
  926.       ScmSetTop (cons);
  927.       ScmCC.nxt_stat += CONS_len;
  928.       break;
  929.     case APPEND:
  930.       tmp = ScmPop ();
  931.       tmp = ScmAppendTwoLists (tmp, ScmPeek ());
  932.       ScmSetTop (tmp);
  933.       ScmCC.nxt_stat += APPEND_len;
  934.       break;
  935.     case LIST_TO_VECTOR:
  936.       ScmListToVector ();
  937.       ScmCC.nxt_stat += LIST_TO_VECTOR_len;
  938.       break;
  939.     case VECTOR:
  940.       siz = cp [1];
  941.       vect = NewScmVector (siz);
  942.       while (siz--)
  943.     vect->array [siz] = ScmPop ();
  944.       ScmPush (vect);
  945.       ScmCC.nxt_stat += VECTOR_len;
  946.       break;
  947.     case TAKE_TRUE:
  948.       ScmPush (&ScmTrue);
  949.       ScmCC.nxt_stat += TAKE_TRUE_len;
  950.       break;
  951.     case TAKE_FALSE:
  952.       ScmPush (&ScmFalse);
  953.       ScmCC.nxt_stat += TAKE_FALSE_len;
  954.       break;
  955.     case TAKE_NIL:
  956.       ScmPush (&ScmNil);
  957.       ScmCC.nxt_stat += TAKE_NIL_len;
  958.       break;
  959.     default:
  960.       error ("bad VM code: %i", (int) cp[0]);
  961.       break;
  962.     }
  963.   }
  964. }
  965.  
  966. void ScmPushPrimitiveContinuation (void *environ, unsigned short stackreq)
  967. {
  968.   assert (active_primitive != SCM_VM_TRAP_CONT);
  969.   reverse_old = environ;
  970.   ScmPushContinuation (stackreq);
  971.   ScmCC.environ = reverse_old;
  972.   ScmCC.nxt_stat = active_primitive;
  973.   reverse_old = NULL;
  974. }
  975.  
  976. /*
  977.  * Scheme's assembly language
  978.  */
  979.  
  980. static
  981. unsigned short *label_address = NULL;
  982. static
  983. int label_count = 0;
  984.  
  985. static
  986. void provide_n_labels (int n)
  987. {
  988.   if (n > label_count) {
  989.     label_address = label_count == 0
  990.         ? (unsigned short *) malloc (n * sizeof (unsigned short))
  991.         : (unsigned short *) realloc (label_address,
  992.                     n * sizeof (unsigned short));
  993.     if (label_address == NULL) {
  994.       label_count = 0;
  995.       reset ("Out of memory");
  996.     }
  997.     label_count = n;
  998.   }
  999. }
  1000.  
  1001. static
  1002. struct stat_desc *get_stat (void *opsym)
  1003. {
  1004.   if (ScmTypeOf (opsym) == ScmType (Symbol))
  1005.     return
  1006.       find_stat (((ScmSymbol *) opsym)->array, ((ScmSymbol *) opsym)->length);
  1007.   else if (ScmTypeOf (opsym) == ScmType (String))
  1008.     return
  1009.       find_stat (((ScmString *) opsym)->array, ((ScmString *) opsym)->length);
  1010.   else
  1011.     error ("vscm-asm: bad operation symbol: %w", opsym);
  1012. }
  1013.  
  1014. static
  1015. unsigned get_label_addresses (int nlabels, void *asmlist)
  1016. {
  1017.   void *stat;
  1018.   unsigned pc;
  1019.  
  1020.   pc = 0;
  1021.   provide_n_labels (nlabels);
  1022.   while (ScmTypeOf (asmlist) == ScmType (Cons)) {
  1023.     stat = ((ScmCons *) asmlist)->car;
  1024.     asmlist = ((ScmCons *) asmlist)->cdr;
  1025.     if (ScmTypeOf (stat) == ScmType (Cons))
  1026.       pc += get_stat (((ScmCons *) stat)->car)->length;
  1027.     else if (ScmTypeOf (stat) == ScmType (ExactNumber)) {
  1028.       label_address [ScmNumberToInt (stat)] = pc;
  1029.     } else
  1030.       error ("vscm-asm: bad assembly code: %w -- %w", stat, asmlist);
  1031.   }
  1032.   return pc;
  1033. }
  1034.  
  1035. static void check_0 (void *x)
  1036. {
  1037.   if (ScmTypeOf (x) != ScmType (Cons))
  1038.     error ("check_0 failed: %w", x);
  1039. }
  1040.  
  1041. static void check_1 (void *x)
  1042. {
  1043.   if (ScmTypeOf (x) != ScmType (Cons))
  1044.     error ("check_1 failed: %w", x);
  1045.   check_0 (((ScmCons *) x)->cdr);
  1046. }
  1047.  
  1048. static void check_2 (void *x)
  1049. {
  1050.   if (ScmTypeOf (x) != ScmType (Cons))
  1051.     error ("check_2 failed: %w", x);
  1052.   check_1 (((ScmCons *) x)->cdr);
  1053. }
  1054.  
  1055. static unsigned short get_0 (void *x)
  1056. {
  1057.   return ScmNumberToInt (((ScmCons *) x)->car);
  1058. }
  1059.  
  1060. static unsigned short get_1 (void *x)
  1061. {
  1062.   return get_0 (((ScmCons *) x)->cdr);
  1063. }
  1064.  
  1065. static unsigned short get_2 (void *x)
  1066. {
  1067.   return get_1 (((ScmCons *) x)->cdr);
  1068. }
  1069.  
  1070. static ScmCode *do_asm (void *, void *);
  1071.  
  1072. static
  1073. ScmCode *do_assembly (
  1074.   unsigned short argcnt, int takerest, void *names, void *constants,
  1075.   unsigned short stackreq, int nlabels, void *asmlist, void *nsym)
  1076. {
  1077.   unsigned short length = get_label_addresses (nlabels, asmlist);
  1078.   ScmCode *code;
  1079.   unsigned nconstants = ScmListLength (constants);
  1080.   ScmVector *cvect;
  1081.   unsigned pc;
  1082.   void *stat;
  1083.   struct stat_desc *desc;
  1084.   unsigned i;
  1085.   unsigned short tmp;
  1086.  
  1087.   constants_save = constants;
  1088.   reverse_old = asmlist;
  1089.   reverse_new = names;
  1090.   append_save = nsym;
  1091.   ScmPush (constants_save);
  1092.   ScmPush (reverse_old);
  1093.   reverse_old = NULL;
  1094.   code = getmem (ScmType (Code),
  1095.          sizeof (ScmCode) + (length - 1) * sizeof (unsigned short));
  1096.   code->length = length;
  1097.   code->arg_cnt = argcnt;
  1098.   code->take_rest = takerest;
  1099.   code->stack_requirement = stackreq;
  1100.   code->argument_names = reverse_new;
  1101.   code->proc_name = append_save;
  1102.   append_save = reverse_new = NULL;
  1103.   ScmPush (code);
  1104.   cvect = NewScmVector (nconstants);
  1105.   code = ScmPop ();
  1106.   code->constants = cvect;
  1107.  
  1108.   pc = 0;
  1109.   for (asmlist = ScmPop (); ScmTypeOf (asmlist) == ScmType (Cons);
  1110.     asmlist = ((ScmCons *) asmlist)->cdr) {
  1111.     stat = ((ScmCons *) asmlist)->car;
  1112.     if (ScmTypeOf (stat) == ScmType (Cons)) {
  1113.       desc = get_stat (((ScmCons *) stat)->car);
  1114.       code->array [pc] = desc->opcode;
  1115.       switch (desc->opcode) {
  1116.       case GET_LOC:
  1117.       case GET_GLOB:
  1118.       case PUT_LOC:
  1119.       case PUT_GLOB:
  1120.       case PUT_LOC_POP:
  1121.       case PUT_GLOB_POP:
  1122.       case TAKE:
  1123.       case CALL:
  1124.       case CALL_AND_EXIT:
  1125.       case LAMBDA:
  1126.       case DELAY:
  1127.       case VECTOR:
  1128.     check_1 (stat);
  1129.     tmp = get_1 (stat);
  1130.     code->array [pc + 1] = tmp;
  1131.     break;
  1132.       case JUMP:
  1133.       case POP_JUMP_IF_FALSE:
  1134.       case POP_JUMP_IF_TRUE:
  1135.       case JUMP_IF_FALSE_ELSE_POP:
  1136.       case JUMP_IF_TRUE_ELSE_POP:
  1137.       case JUMP_IF_FALSE_POP:
  1138.       case JUMP_IF_TRUE_POP:
  1139.     check_1 (stat);
  1140.     tmp = label_address [get_1 (stat)] - pc - desc->length;
  1141.     code->array [pc + 1] = tmp;
  1142.     break;
  1143.       case JUMP_BACK:
  1144.     check_1 (stat);
  1145.     tmp = pc + desc->length - label_address [get_1 (stat)];
  1146.     code->array [pc + 1] = tmp;
  1147.     break;
  1148.       case GET_ENV:
  1149.       case PUT_ENV:
  1150.       case PUT_ENV_POP:
  1151.       case FRAME:
  1152.       case FILL_FRAME:
  1153.     check_2 (stat);
  1154.     tmp = get_1 (stat);
  1155.     code->array [pc + 1] = tmp;
  1156.     tmp = get_2 (stat);
  1157.     code->array [pc + 2] = tmp;
  1158.     break;
  1159.       case JUMP_IF_NOT_MEMV:
  1160.     check_2 (stat);
  1161.     tmp = label_address [get_1 (stat)] - pc - desc->length;
  1162.     code->array [pc + 1] = tmp;
  1163.     tmp = get_2 (stat);
  1164.     code->array [pc + 2] = tmp;
  1165.     break;
  1166.       default:
  1167.     /* do nothing */
  1168.     break;
  1169.       }
  1170.       pc += desc->length;
  1171.     }
  1172.   }
  1173.   constants_save = ScmPop ();
  1174.   for (i = 0; i < nconstants; i++) {
  1175.     stat = ((ScmCons *) constants_save)->car;
  1176.     constants_save = ((ScmCons *) constants_save)->cdr;
  1177.     if (ScmTypeOf (stat) != ScmType (Cons))
  1178.       error ("vscm-asm: bad constant: %w", stat);
  1179.     if (((ScmCons *) stat)->car == ScmQuotePtr) {
  1180.       stat = ((ScmCons *) stat)->cdr;
  1181.       if (ScmTypeOf (stat) != ScmType (Cons))
  1182.     error ("vscm-asm: bad quotation: %w", stat);
  1183.       else
  1184.     code->constants->array [i] = ((ScmCons *) stat)->car;
  1185.     } else {
  1186.       append_save = code->proc_name;
  1187.       ScmPush (code);
  1188.       ScmPush (constants_save);
  1189.       nsym = append_save;
  1190.       append_save = NULL;
  1191.       stat = do_asm (stat, nsym);
  1192.       constants_save = ScmPop ();
  1193.       code = ScmPop ();
  1194.       code->constants->array [i] = stat;
  1195.     }
  1196.   }
  1197.   constants_save = NULL;
  1198.   return code;
  1199. }
  1200.  
  1201. static ScmCode *do_asm (void *stat, void *nsym)
  1202. {
  1203.   unsigned short new_argcnt;
  1204.   int new_takerest;
  1205.   void *new_names;
  1206.   void *new_constants;
  1207.   unsigned int new_stackreq;
  1208.   int new_nlabels;
  1209.  
  1210.   check_0 (stat);
  1211.   if (ScmTypeOf (((ScmCons *) stat)->car) == ScmType (String)) {
  1212.     nsym = ((ScmCons *) stat)->car;
  1213.     stat = ((ScmCons *) stat)->cdr;
  1214.     check_0 (stat);
  1215.   }
  1216.   new_argcnt = get_0 (stat);
  1217.   stat = ((ScmCons *) stat)->cdr;
  1218.   check_0 (stat);
  1219.   /* Since several Schemes write () for #f, we have to check for #t here */
  1220.   new_takerest = (((ScmCons *) stat)->car == &ScmTrue ? 1 : 0);
  1221.   stat = ((ScmCons *) stat)->cdr;
  1222.   check_0 (stat);
  1223.   new_names = ((ScmCons *) stat)->car;
  1224.   stat = ((ScmCons *) stat)->cdr;
  1225.   check_0 (stat);
  1226.   new_constants = ((ScmCons *) stat)->car;
  1227.   stat = ((ScmCons *) stat)->cdr;
  1228.   check_0 (stat);
  1229.   new_stackreq = get_0 (stat);
  1230.   stat = ((ScmCons *) stat)->cdr;
  1231.   check_0 (stat);
  1232.   new_nlabels = get_0 (stat);
  1233.   stat = ((ScmCons *) stat)->cdr;
  1234.   return do_assembly (new_argcnt, new_takerest, new_names, new_constants,
  1235.         new_stackreq, new_nlabels, stat, nsym);
  1236. }
  1237.  
  1238. void *ScmAsm (void *asmlist)
  1239. {
  1240.   ScmCode *code = do_asm (asmlist, NULL);
  1241.   ScmProcedure *proc;
  1242.  
  1243.   ScmPush (code);
  1244.   proc = new (ScmType (Procedure));
  1245.   proc->code = ScmPop ();
  1246.   proc->env = NULL;
  1247.   return proc;
  1248. }
  1249.  
  1250. void *ScmAsmDcl (void *dcl)
  1251. {
  1252.   ScmProcedure *proc;
  1253.   ScmSymbol *sym;
  1254.  
  1255.   if (ScmTypeOf (dcl) != ScmType (Cons))
  1256.     fatal ("Atomic asm/dcl");
  1257.   if (((ScmCons *) dcl)->car == ScmDefinePtr) {
  1258.     dcl = ((ScmCons *) dcl)->cdr;
  1259.     if (ScmListLength (dcl) != 2)
  1260.       fatal ("Bad define for asm/dcl");
  1261.     sym = ((ScmCons *) dcl)->car;
  1262.     if (ScmTypeOf (sym) != ScmType (Symbol))
  1263.       fatal ("asm/dcl: definition of non-symbol");
  1264.     dcl = ((ScmCons *) ((ScmCons *) dcl)->cdr)->car;
  1265.     if (ScmListLength (dcl) == 2 && ((ScmCons *) dcl)->car == ScmQuotePtr)
  1266.       sym->value = ((ScmCons *) ((ScmCons *) dcl)->cdr)->car;
  1267.     else {
  1268.       ScmPush (sym);
  1269.       ScmPush (do_asm (dcl, sym));
  1270.       proc = new (ScmType (Procedure));
  1271.       proc->env = NULL;
  1272.       proc->code = ScmPop ();
  1273.       sym = ScmPop();
  1274.       sym->value = proc;
  1275.     }
  1276.   } else {
  1277.     ScmPush (do_asm (dcl, NULL));
  1278.     proc = new (ScmType (Procedure));
  1279.     proc->env = NULL;
  1280.     proc->code = ScmPop ();
  1281.     return proc;
  1282.   }
  1283.   return NULL;
  1284. }
  1285.